home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / mexp.em < prev    next >
Lisp/Scheme  |  1993-06-16  |  2KB  |  72 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: mexp.em
  4. ;; Date: Tue Mar  3 12:49:44 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9. ;; Fast macroexpansion
  10.  
  11. (defmodule mexp
  12.   (standard0
  13.    ;;list-fns
  14.    
  15.    module-operators
  16.    )
  17.   ()
  18.  
  19.   (defmacro expand-forms ()
  20.     `(do-expand (car (reify-env))))
  21.  
  22.   (defun do-expand (name)
  23.     (let ((infile (open (format nil "~a.em" name)))
  24.       (outfile (open (format nil "/tmp/~a.em" name) 'output t)))
  25.       (let ((forms (read infile)))
  26.     (let ((res (expand-forms-1 forms name)))
  27.       (write res outfile)
  28.       (format outfile "~%~%")
  29.       (close outfile)
  30.       (close infile))))
  31.     nil)
  32.  
  33.   (defun expand-forms-1 (x m)
  34.     (cond ((null x) nil)
  35.       ((atom x) x)
  36.       ((eq (car x) 'quote)
  37.        x)
  38.       ((eq (car x) 'lambda)
  39.        (cons 'lambda (cons (cadr x)
  40.                    (mapcar (lambda (form) (expand-forms-1 form m))
  41.                        (cddr x)))))
  42.       (t (let ((xx (macro-namep (car x) m)))
  43.            (if xx
  44.            (expand-forms-1 (apply xx (cdr x))
  45.                    m)
  46.          (cons (expand-forms-1 (car x) m)
  47.                (my-mapcar (lambda (form) 
  48.                     (expand-forms-1 form m))
  49.                   (cdr x))))))))
  50.                    
  51.   
  52.      
  53.   (defun macro-namep (sym mod)
  54.     (if (symbolp sym)
  55.     (if (dynamic-accessible-p (get-module mod) sym)
  56.         (let ((xx (dynamic-access (get-module mod) sym)))
  57.           (if (macrop xx) 
  58.           xx
  59.         nil))
  60.       nil)
  61.       nil))
  62.   
  63.   (defun my-mapcar (fn l)
  64.     (cond ((null l) nil)
  65.       ((atom l) l)
  66.       (t (cons (fn (car l)) 
  67.            (my-mapcar fn (cdr l))))))
  68.  
  69.   (export expand-forms expand-forms-1 reify-env do-expand)
  70.   ;; end module
  71.   )
  72.